Developer CD Series 1996 May: Tool Chest/Developer CD Series May 1996 (Tool Chest) (Apple Computer) (1996).iso/Tool Chest/Development Tools & Languages/Dylan Related/Mindy/Mindy 1.2 - portable sources/libraries/print/print.dylan

Text File | 1995-03-15 | 35.1 KB | 1,129 lines | [TEXT/ttxt]

module: Print
author: [e-mail]
synopsis: This file implements object printing.
copyright: See below.
rcs-header: $Header: print.dylan,v 1.10 94/11/28 15:50:07 wlott Exp $

//======================================================================
//
// Copyright (c) 1994  Carnegie Mellon University
// All rights reserved.
//
// Use and copying of this software and preparation of derivative
// works based on this software are permitted, including commercial
// use, provided that the following conditions are observed:
//
// 1. This copyright notice must be retained in full on any copies
//    and on appropriate parts of any derivative works.
// 2. Documentation (paper or online) accompanying any system that
//    incorporates this software, or any part of it, must acknowledge
//    the contribution of the Gwydion Project at Carnegie Mellon
//    University.
//
// This software is made available "as is".  Neither the authors nor
// Carnegie Mellon University make any warranty about the software,
// its performance, or its conformity to any specification.
//
// Bug reports, questions, comments, and suggestions should be sent by
// E-mail to the Internet address "[e-mail]".
//
//======================================================================
//



/// <print-stream> class.
///

/// <print-stream> Class -- Exported.
///
/// These streams hold print state so that the print function can do most
/// of the work maintaining print state, and the print-object function can
/// just print objects, querying the state of the stream as necessary.  Each
/// slot defaults to the value of a global variable upon creation (see the
/// comments for the print function).
///
define sealed class <print-stream> (<stream>)
  //
  // Print-target holds the real destination of the print-stream.
  slot print-target :: <stream>, required-init-keyword: #"stream";
  //
  // Print-level holds the maximum depth to which the user wants recursive
  // printing to go.
  slot print-level :: false-or(<fixed-integer>),
    init-function: method () *default-level* end,
    init-keyword: #"level";
  //
  // Print-depth holds the current level of printing.  When incremeting this
  // slot causes the depth to exceed print-level, then the print function
  // only outputs $print-level-exceeded-string.
  slot print-depth :: <fixed-integer>, init-value: -1;
  //
  // Print-length holds the maximum number of elements the user wants a
  // sequence to be printed.  This does not apply to some sequences, such as
  // strings.
  slot print-length :: false-or(<fixed-integer>),
    init-function: method () *default-length* end,
    init-keyword: #"length";
  //
  // Print-pretty? holds whether the user wants pretty printing.
  slot print-pretty? :: <boolean>,
    init-function: method () *default-pretty?* end,
    init-keyword: #"pretty?";
  //
  // Print-circle? holds whether the user wants pretty printing.
  slot print-circle? :: <boolean>,
    init-function: method () *default-circle?* end,
    init-keyword: #"circle?";
  //
  // Circular-first-pass? indicates to the print function whether it is on
  // the first pass of printing, in which it just builds a table of objects
  // referenced during the printing.  On the second pass of printing, print
  // actually generates output.
  slot circular-first-pass? :: <boolean>, init-value: #t;
  //
  // Circular-references is a table of objects referenced during printing
  // when print-circle? is #t.
  slot circular-references :: false-or(<object-table>),
    init-value: #f;
  //
  // Circular-next-id holds the next ID to use when printing circularly.
  // Each time print sees an object for a second time during the first
  // printing pass, print assigns as the object's ID the current value of
  // this slot.
  slot circular-next-id :: <fixed-integer>, init-value: 0;
end class;



/// <print-reference> Class.
///

/// <print-reference> Class -- Internal.
///
/// These objects hold information about object references encountered when
/// print-circle? is #t.  The print function creates these objects in a fake
/// first printing pass, and then it uses these objects during a real second
/// printing pass to determine whether the object needs to be tagged,
/// printed normally, or printed by reference to the objects circular ID to
/// avoid infinite recursive printing.
///
define sealed class <print-reference> (<object>)
  //
  // This slot holds the object referenced during printing.
  slot print-reference-object, init-keyword: #"object";
  //
  // This slot holds the object's ID for circular references.  The object
  // prints as its ID after the first time.  Before the first time the object
  // is printed, this slot is #f.
  slot print-reference-id :: false-or(<byte-string>),
    init-value: #f;
  //
  // This slot counts the number of references to the object.
  slot print-reference-count :: <fixed-integer>, init-value: 0;
end class;



/// Print-reference routines.
///

/// print-reference -- Internal Interface.
///
/// This function returns the print-reference object associated with object.
/// If none exists, then this creates a print-reference and installs it in
/// the circular-references table.
///
define method print-reference (object, stream :: <print-stream>)
    => ref :: <print-reference>;
  let table = stream.circular-references;
  let ref = element(table, object, default: #f);
  if (ref)
    ref;
  else
    let ref = make(<print-reference>, object: object);
    element(table, object) := ref;
  end;
end method;

/// new-print-reference-id -- Internal Interface.
///
/// This function gets the next circular print reference ID, assigns it to ref,
/// and updates the stream so that it doesn't return the same ID again.
///
define method new-print-reference-id (stream :: <print-stream>,
                      ref :: <print-reference>)
    => ID :: <byte-string>;
  let id = stream.circular-next-id;
  stream.circular-next-id := id + 1;
  ref.print-reference-id := integer-to-string(id);
end method;

/// This vector is used by integer-to-string to convert digits to characters.
///
define constant $digit-characters = "0123456789";

/// integer-to-string -- Internal.
///
/// This converts a integer to a byte-string.
///
/// This function makes the trade off that consing and throwing away a list
/// (that probably never ascends to an elder GC generation) is better than
/// isolating access to a global vector that lies around across calls to
/// this function.  There was no profiling to validate this trade-off.
///
define sealed method integer-to-string (arg :: <integer>)
    => res :: <byte-string>;
  local method repeat (arg, digits)
      let (quotient, remainder) = floor/(arg, 10);
      let digits = pair($digit-characters[remainder], digits);
      if (zero?(quotient))
        digits;
      else
        repeat(quotient, digits);
      end;
    end;
  as(<byte-string>,
     if (negative?(arg))
       pair('-', repeat(- arg, #()));
     else
       repeat(arg, #());
     end);
end;


/// Print-{level,length,depth,pretty?,circle?} generics and default methods.
///

/// print-length -- Exported.
///
define sealed generic print-length (stream :: <stream>)
    => length :: false-or(<fixed-integer>);

define method print-length (stream :: <stream>)
    => length :: singleton(#f);
  #f;
end method;


/// print-level -- Exported.
///
define sealed generic print-level (stream :: <stream>)
    => level :: false-or(<fixed-integer>);

define method print-level (stream :: <stream>)
    => level :: singleton(#f);
  #f;
end method;


/// print-depth -- Exported.
///
define sealed generic print-depth (stream :: <stream>)
    => depth :: <fixed-integer>;

define method print-depth (stream :: <stream>)
    => depth :: singleton(0);
  0;
end method;


/// print-pretty? -- Exported.
///
define sealed generic print-pretty? (stream :: <stream>)
    => pretty? :: <boolean>;

define method print-pretty? (stream :: <stream>)
    => pretty? :: singleton(#f);
  #f;
end method;


/// print-circle? -- Exported.
///
define sealed generic print-circle? (stream :: <stream>)
    => circle? :: <boolean>;

define method print-circle? (stream :: <stream>)
    => circle? :: singleton(#f);
  #f;
end method;



/// Print and global defaults.
///

/// These provide the default values for the keywords to print.  #f means
/// there are no bounds, special checks for circularity, or pretty printing.
///
define variable *default-level* :: false-or(<fixed-integer>) = #f;
define variable *default-length* :: false-or(<fixed-integer>) = #f;
define variable *default-circle?* :: <boolean> = #f;
define variable *default-pretty?* :: <boolean> = #f;

/// Get a unique address to use as the default value for the print function's
/// keyword arguments so that it can tell when the user supplies keywords.
///
define constant $unsupplied-arg = pair(#f, #f);

/// What to print when the current depth exceeds the users requested print
/// level limit.
///
define constant $print-level-exceeded-string :: <byte-string> = "#";

/// What to print before a circular print ID.
///
define constant $circular-id-prestring :: <byte-string> = "#";

/// What to print after a circular print ID.
///
define constant $circular-id-poststring :: <byte-string> = "#";


/// Print -- Exported.
///
define generic print (object, stream :: <stream>,
              #key level, length, circle?, pretty?)
    => ();


/// Print -- Method for Exported Interface.
///
/// This method must regard the values of the keywords and construct a
/// <print-stream> to hold the values for the requested print operation.
///
define method print (object, stream :: <stream>,
             #key level = $unsupplied-arg,
                  length = $unsupplied-arg,
                  circle? = $unsupplied-arg,
                  pretty? = $unsupplied-arg)
    => ();
  block ()
    //
    // Lock the stream so that all the calls to print-object build output
    // contiguously, without intervening threads screwing up the print
    // request.
    lock-stream(stream);
    //
    // Make the stream defaulting the slots to the global default values for
    // the keyword arguments.  No need to lock this stream because only this
    // thread should have any references to it ... barring extreme user
    // silliness.
    let p-stream = make(<print-stream>, stream: stream);
    //
    // Set slots with those values supplied by the user.
    if (~ (level == $unsupplied-arg)) p-stream.print-level := level end;
    if (~ (length == $unsupplied-arg)) p-stream.print-length := length end;
    if (~ (circle? == $unsupplied-arg)) p-stream.print-circle? := circle? end;
    if (~ (pretty? == $unsupplied-arg)) p-stream.print-pretty? := pretty? end;
    //
    // When printing circularly, we first print to a "null stream" so that we
    // can find the circular references.
    if (p-stream.print-circle?)
      start-circle-printing(object, p-stream);
    end;
    //
    // Determine whether, and how, to print object.
    maybe-print-object(object, p-stream);
  cleanup
    unlock-stream(stream);
  end;
end method;

/// Print -- Method for Exported Interface.
///
/// This method must regard the values of the keywords and construct a
/// <print-stream> to hold the values for the requested print operation.
///
define method print (object, stream :: <print-stream>,
             #key level = $unsupplied-arg,
              length = $unsupplied-arg,
                  circle? = $unsupplied-arg,
                  pretty? = $unsupplied-arg)
    => ();
  let save-level = stream.print-level;
  let save-length = stream.print-length;
  let save-circle? = stream.print-circle?;
  let save-pretty? = stream.print-pretty?;
  block ()
    //
    // Establish changes in policy for this call to print.
    // If level is supplied, and there was already a level in effect, we
    // continue printing with the minimum effect of the two levels, assuming
    // that is the most careful thing to do.
    case
      (level = $unsupplied-arg) => #f;   // Case is broken in Mindy.
      (save-level) =>
    stream.print-level := min(save-level, (level + stream.print-depth));
      otherwise => stream.print-level := level;
    end;
    // If length is supplied, and there was already a length in effect, we
    // continue printing with the minimum of the two lengths, assuming that
    // is the most careful thing to do.
    case
      (length = $unsupplied-arg) => #f;   // Case is broken in Mindy.
      (save-length) => stream.print-length := min(save-length, length);
      otherwise => stream.print-length := length;
    end;
    // We never turn off circular printing, but if a recursive call to print
    // turns circular printing on, we print that object circularly.
    case
      ((circle? = $unsupplied-arg) | (~ circle?)) =>
    #f;   // Case is broken in Mindy.
      (~ save-circle?) =>
    stream.print-circle? := #t;
    start-circle-printing(object, stream);
    end;
    // Printing pretty gets turned on and off for each user-supplied value
    // passed to print.  The assumption is that there is no harm in turning
    // it off for some object, and because it is odd to request no pretty
    // printing, the calling code probably has good reason to turn it off.
    if (~ (pretty? == $unsupplied-arg)) stream.print-pretty? := pretty? end;
    //
    // Determine whether, and how, to print object.
    maybe-print-object(object, stream);
  cleanup
    stream.print-level := save-level;
    stream.print-length := save-length;
    stream.print-circle? := save-circle?;
    stream.print-pretty? := save-pretty?;
  end;
end method;

/// start-circle-printing -- Internal.
///
/// This function makes sure the stream has a circular-references table,
/// makes sure object has a print-reference, checks for circular references
/// within object, and considers what sort of output may be necessary to
/// define a tag for object or print object's tag.
///
/// This function is called both from the very first call to print and
/// recursive calls to print.  The calls to start-circle-printing within
/// recursive calls to print occur when the original call to print had
/// circular printing turned off, and the recursive calls to print turn
/// circular printing on.  Because of this function's use within recursive
/// calls to print, it cannot make certain assumptions:
///    Whether stream already has a circular-references table.
///    Whether there already is a print-reference for object.
///    What print-reference-count is for object.
///    Whether to do a first pass on object looking for circular references.
///    Whether object already has a print-reference-id.
///
/// Recursive calls to print cannot turn off circular printing, so we don't
/// have to account for that.
///
define method start-circle-printing (object, stream :: <print-stream>)
    => ();
  let table = stream.circular-references;
  if (~ table)
    table := make(<object-table>);
    stream.circular-references := table;
  end;
  let ref = print-reference(object, stream);
  let count :: <fixed-integer> = (ref.print-reference-count + 1);
  ref.print-reference-count := count;
  if (count = 1)
    // If this is the first time we've seen this object, then dive into it
    // looking for circular references.
    stream.circular-first-pass? := #t;
    print-object(object, stream);
    stream.circular-first-pass? := #f;
  end;
end method;

/// maybe-print-object -- Internal.
///
/// This function increments print-depth and regards print-level to see
/// whether it should print object.  If it should print object, then it
/// regards print-circle? and does the right thing.
///
define method maybe-print-object (object, stream :: <print-stream>)
  let depth :: <fixed-integer> = (stream.print-depth + 1);
  block ()
    stream.print-depth := depth;
    let requested-level :: false-or(<fixed-integer>) = stream.print-level;
    case
      (requested-level & (depth > requested-level)) =>
    write($print-level-exceeded-string, stream);
      (~ stream.print-circle?) =>
    print-object(object, stream);
      (stream.circular-first-pass?) =>
    // When printing circularly, we first print to a "null stream" so
    // that we can find the circular references.
    let ref = print-reference(object, stream);
    let ref-count = (ref.print-reference-count + 1);
    ref.print-reference-count := ref-count;
    if (ref-count = 1)
      // If ref-count is already greater than one, then there's
      // no reason to go further into the object gathering references.
      print-object(object, stream);
    end;
      otherwise
    output-print-reference(print-reference(object, stream),
                   stream);
    end case;
  cleanup
    stream.print-depth := depth - 1;
  end;
end method;

/// output-print-reference -- Internal.
///
/// This function determines how to output a print-reference for circular
/// printing.
///
define method output-print-reference (ref :: <print-reference>,
                      stream :: <stream>)
    => ();
  let ref-id = ref.print-reference-id;
  case
    (ref.print-reference-count = 1) =>
      print-object(ref.print-reference-object, stream);
    (~ ref-id) =>
      write($circular-id-prestring, stream);
      write(new-print-reference-id(stream, ref), stream);
      write($circular-id-poststring, stream);
      write("=", stream);
      print-object(ref.print-reference-object, stream);
    otherwise =>
      write($circular-id-prestring, stream);
      write(ref-id, stream);
      write($circular-id-poststring, stream);
  end;
end method;



/// Print-object generic and default method.
///

/// print-object -- Exported.
///
define generic print-object (object, stream :: <stream>)
    => ();

/// Any object.
///
/// This method prints as many slot value pairs as it can without exceeding
/// print-length and counting each pair as two elements.  This method does
/// not count "Foo instance" in any way in the length calculation.
///
define method print-object (object :: <object>, stream :: <stream>)
    => ();
  pprint-logical-block
    (stream,
     prefix: "{",
     body: method (stream)
         let obj-class = object.object-class;
         write-class-name(obj-class, stream);
         write(" instance", stream);
         let descriptors = obj-class.slot-descriptors;
         if (~ (descriptors = #()))
           write(", ", stream);
           pprint-indent(#"block", 2, stream);
           pprint-newline(#"linear", stream);
           // Print slot names and values.
           pprint-logical-block
         (stream,
          prefix: #f,
          body: method (stream)
              block (exit)
                let length :: false-or(<fixed-integer>)
                  = stream.print-length;
                for (desc in descriptors,
                 // Count each slot name and value as two
                 // for considerations of print-length.
                 count = 0 then (count + 2))
                  if (count ~= 0)
                write(", ", stream);
                pprint-newline(#"linear", stream);
                  end;
                  if (length & (count >= length))
                write("...", stream);
                exit();
                  end;
                  write(as(<byte-string>, desc.slot-name), stream);
                  write(": ", stream);
                  pprint-newline(#"fill", stream);
                  let (value, win?) = slot-value(desc, object);
                  if (win?)
                print(value, stream);
                  else
                write("{UNINITIALIZED}", stream);
                  end;
                end for;
              end block;
            end method,
          suffix: #f);
         end if;
       end method,
     suffix: "}");
end method;



/// Print-object <byte-string> and <byte-character> methods.
///

/// This is used in the print-object method for <byte-string>.
///
define constant byte-string-escape-chars
    = make(<vector>, size: 256, fill: #f);
byte-string-escape-chars[as(<byte>, '\0')] := '0';
byte-string-escape-chars[as(<byte>, '\a')] := 'a';
byte-string-escape-chars[as(<byte>, '\b')] := 'b';
byte-string-escape-chars[as(<byte>, '\t')] := 't';
byte-string-escape-chars[as(<byte>, '\f')] := 'f';
byte-string-escape-chars[as(<byte>, '\r')] := 'r';
byte-string-escape-chars[as(<byte>, '\n')] := 'n';
byte-string-escape-chars[as(<byte>, '\e')] := 'e';
byte-string-escape-chars[as(<byte>, '"')] := '"';
byte-string-escape-chars[as(<byte>, '\\')] := '\\';

/// Byte-strings.
///
define method print-object (object :: <byte-string>, stream :: <stream>)
    => ();
  write('"', stream);
  let i :: <fixed-integer> = 0;
  let len :: <fixed-integer> = object.size;
  while (i < len)
    // Find a char that requires an escape (call it the special char).
    for (j :: <fixed-integer> = i then (j + 1),
     until ((j = len) | byte-string-escape-chars[as(<byte>, object[j])]))
    finally
      // Print from the last special char to this one.
      write(object, stream, start: i, end: j);
      // Print the escape character followed by the special character.
      if (j < len)
    write('\\', stream);
    write(byte-string-escape-chars[as(<byte>, object[j])], stream);
      end;
      // Move past the special character.
      i := (j + 1);
    end;
  end;
  write('"', stream);
end method;

/// Byte-characters.
///
define method print-object (object :: <byte-character>, stream :: <stream>)
    => ();
  write('\'', stream);
  case
    (byte-string-escape-chars[as(<byte>, object)]) =>
    write('\\', stream);
    write(byte-string-escape-chars[as(<byte>, object)], stream);
    (object = '\'') =>
    write('\\', stream);
    write('\'', stream);
    otherwise =>
      write(object, stream);
  end;
  write('\'', stream);
end method;



/// Print-object <list> method.
///

/// For circular printing to be correct, we need to count references to the
/// tail pointers as well as the head pointers.  Because we do not print lists
/// by calling print on the tail of each pair, we need to specially handle
/// the tail pointers in this method.  The object passed in and all head
/// pointers are handled naturally via calls to print.
///
define method print-object (object :: <list>, stream :: <stream>) => ();
  pprint-logical-block(stream,
               prefix: "#(",
               body: method (stream)
                   if (~ (object == #()))
                 print-list(object, stream);
                   end;
                 end,
               suffix: ")");
end method;

define method print-list (object :: <list>, stream :: <stream>) => ();
  block(exit)
    let length :: false-or(<fixed-integer>) = stream.print-length;
    if (length & (length <= 0))
      write("...", stream);
    else
      print(object.head, stream);
      let circle? = stream.print-circle?;
      let first-pass? = stream.circular-first-pass?;
      for (remaining = object.tail then remaining.tail,
       count = 1 then (count + 1),
       until (remaining == #()))
    write(", ", stream);
    pprint-newline(#"fill", stream);
    case
      (~ instance?(remaining, <list>)) =>
        // Object was not a proper list, so print dot notation.
        write(". ", stream);
        pprint-newline(#"fill", stream);
        print(remaining, stream);
        exit();
      (length & (count >= length)) =>
        // We've exceeded print-length for this print request.
        write("...", stream);
        exit();
      (~ circle?) =>
        // No circular printing, so this is the simple and normal case.
        print(remaining.head, stream);
      (first-pass?) =>
        // Get or create the print-reference for the remaining pointer.
        let ref = print-reference(remaining, stream);
        let ref-count = (ref.print-reference-count + 1);
        ref.print-reference-count := ref-count;
        if (ref-count = 1)
          // First time through, so keep gathering references.
          print(remaining.head, stream);
        else
          // If ref-count is already greater than one, then we've seen
          // everything once.  Stop iterating.
          exit();
        end;
      otherwise =>
        // Circular printing on the second pass.
        let ref = print-reference(remaining, stream);
        let ref-id = ref.print-reference-id;
        case
          (ref.print-reference-count = 1) =>
        // Only one reference to the rest of the list, so print the
        // remaining elements normally.
        print(remaining.head, stream);
          (~ ref-id) =>
        // Print the tag and its value with dot notation so that
        // the rest of the list does not appear to be a single
        // element of the list (that is, a nested list).
        write(". ", stream);
        pprint-newline(#"fill", stream);
        write($circular-id-prestring, stream);
        write(new-print-reference-id(stream, ref), stream);
        write($circular-id-poststring, stream);
        write("=", stream);
        print(remaining, stream);
          otherwise =>
        // Print the tag with dot notation.  See previous cases's
        // comment.
        write(". ", stream);
        pprint-newline(#"fill", stream);
        write($circular-id-prestring, stream);
        write(ref-id, stream);
        write($circular-id-poststring, stream);
        exit();
        end case;
    end case;
      end for;
    end if;
  end block;
end method;


/// Print-object <simple-object-vector> method.
///

/// Vectors.
///
define method print-object (object :: <simple-object-vector>,
                stream :: <stream>)
    => ();
  pprint-logical-block(stream,
               prefix: "#[",
               body: method (stream)
                   print-items(object, print, stream);
                 end method,
               suffix: "]");
end method;



/// Print-object <function> method.
///

/// Functions.
///
define method print-object (object :: <function>, stream :: <stream>)
    => ();
  pprint-logical-block
    (stream,
     prefix: "{",
     body: method (stream)
         case
           (instance?(object, <generic-function>)) =>
         write("GF", stream);
         let name = function-name(object);
         if (name)
           write(' ', stream);
           pprint-newline(#"fill", stream);
           write(as(<byte-string>, name), stream);
         end;
           (instance?(object, <method>)) =>
         write("Method", stream);
         let name = function-name(object);
         if (name)
           write(' ', stream);
           pprint-newline(#"fill", stream);
           write(as(<byte-string>, name), stream);
         end;
         print-function-specializers(object, stream);
           otherwise =>
         write("Function", stream);
         end
       end,
     suffix: "}");
end method;

define method print-function-specializers (object :: <function>,
                       stream :: <stream>)
    => ();
  let specializers = method-specializers(object);
  if (~ (specializers = #()))
    write(' ', stream);
    pprint-newline(#"fill", stream);
    pprint-logical-block
      (stream,
       prefix: "(",
       body: method (stream)
           print-items(specializers, print-specializer, stream);
         end,
       suffix: ")");
  end if;
end method;

/// print-items -- Internal Interface.
///
/// This function prints each element of items, separated by commas, using
/// print-fun.  This function also regards print-length.  Stream must be a
/// pretty printing stream or a <print-stream> whose target is a pretty
/// printing stream, so this function is basically good for use in body:
/// methods passed to pprint-logical-block.
///
/// Do not use this function for collections that may be tail-circular; it
/// will not terminate.
///
define method print-items (items :: <collection>, print-fun :: <function>,
               stream :: <stream>)
    => ();
  block (exit)
    let length :: false-or(<fixed-integer>)
      = stream.print-length;
    let stream-for-apply = list(stream);
    for (x in items,
     count = 0 then (count + 1))
      if (count ~= 0)
    write(", ", stream);
    pprint-newline(#"fill", stream);
      end;
      if (length & (count = length))
    write("...", stream);
    exit();
      end;
      apply(print-fun, x, stream-for-apply);
    end for;
  end block;
end method;



/// Print-specializer generic function and methods.
///

/// This function is used in printing methods.
///

define sealed generic print-specializer (type :: <type>, stream :: <stream>)
    => ();

define method print-specializer (type :: <type>, stream :: <stream>) => ();
  write("{UNKNOWN-TYPE}", stream);
end method;

define method print-specializer (type :: <class>, stream :: <stream>)
    => ();
  write-class-name(type, stream);
end method;

define method print-specializer (type :: <singleton>, stream :: <stream>)
    => ();
  write("{Singleton ", stream);
  print(type.singleton-object, stream);
  write("}", stream);
end method;

define method print-specializer (type :: <subclass>, stream :: <stream>)
    => ();
  write("{Subclasses of ", stream);
  write-class-name(type.subclass-of, stream);
  write("}", stream);
end method;

define method print-specializer (type :: <limited-integer>, stream :: <stream>)
    => ();
  write("{Limited ", stream);
  write-class-name(type.limited-integer-class, stream);
  write(' ', stream);
  print(type.limited-integer-min, stream);
  write("..", stream);
  print(type.limited-integer-max, stream);
  write("}", stream);
end method;

define method print-specializer (type :: <union>, stream :: <stream>)
    => ();
  pprint-logical-block
    (stream,
     prefix: "{",
     body: method (stream)
         write("Union ", stream);
         pprint-newline(#"fill", stream);
         print(type.union-members, stream);
       end method,
     suffix: "}");
end method;



/// Print-object <class> method.
///

/// Classes.
///
define method print-object (object :: <class>, stream :: <stream>) => ();
  write("{Class ", stream);
  write-class-name(object, stream);
  write("}", stream);
end method;

/// write-class-name -- Internal Interface.
///
/// This function writes the name of the class or "<UNNAMED-CLASS>" to stream.
/// It does not output any curly braces, the word "class", or anything else.
///
define method write-class-name (object :: <class>, stream :: <stream>)
    => ();
  let name = class-name(object);
  if (name)
    write(as(<byte-string>, name), stream);
  else
    write("<UNNAMED-CLASS>", stream);
  end;
end method;



/// Print-object miscellaneous methods.
///

/// #t.
///
define method print-object (object :: singleton(#t), stream :: <stream>)
    => ();
  write("#t", stream);
end method;

/// #f.
///
define method print-object (object :: singleton(#f), stream :: <stream>)
    => ();
  write("#f", stream);
end method;

/// Symbols.
///
define method print-object (object :: <symbol>, stream :: <stream>) => ();
  write("#\"", stream);
  write(as(<string>, object), stream);
  write('"', stream);
end method;

/// Integers.
///
define method print-object (object :: <fixed-integer>, stream :: <stream>)
    => ();
  write(integer-to-string(object), stream);
end method;
///
define method print-object (object :: <extended-integer>, stream :: <stream>)
    => ();
  write("#e", stream);
  write(integer-to-string(object), stream);
end method;




/// print-to-string -- Exported.
///
define generic print-to-string (object, #rest args,
                #key level, length, circle?, pretty?)
    => result :: <string>;

define method print-to-string (object, #rest args,
                   #key level, length, circle?, pretty?)
    => result :: <byte-string>;
  let s = make(<byte-string-output-stream>);
  apply(print, object, s, args);
  s.string-output-stream-string;
end method;



/// Streams protocol extensions for <print-stream>s.
///

/// These methods may change when pretty printing goes in.  In particular,
/// getting and releasing the buffer may interact with buffered pretty
/// printing stuff.
///

define constant bogus-buffer = make(<buffer>);

define method stream-extension-get-output-buffer (stream :: <print-stream>)
    => (buffer :: <buffer>, next :: <buffer-index>, size :: <buffer-index>);
  if ((stream.print-circle?) & (stream.circular-first-pass?))
    values(bogus-buffer, 0, bogus-buffer.size);
  else
    stream-extension-get-output-buffer(stream.print-target);
  end;
end method;

define method stream-extension-release-output-buffer
    (stream :: <print-stream>, next :: <buffer-index>)
    => ();
  if (~ ((stream.print-circle?) & (stream.circular-first-pass?)))
    stream-extension-release-output-buffer(stream.print-target, next);
  end;
end method;

define method stream-extension-empty-output-buffer
    (stream :: <print-stream>, stop :: <buffer-index>)
    => ();
  if (~ ((stream.print-circle?) & (stream.circular-first-pass?)))
    stream-extension-empty-output-buffer(stream.print-target, stop);
  end;
end method;

define method stream-extension-force-secondary-buffers
    (stream :: <print-stream>)
    => ();
  if (~ ((stream.print-circle?) & (stream.circular-first-pass?)))
    stream-extension-force-secondary-buffers(stream.print-target);
  end;
end method;

define method stream-extension-synchronize (stream :: <print-stream>)
    => ();
  if (~ ((stream.print-circle?) & (stream.circular-first-pass?)))
    stream-extension-synchronize(stream.print-target);
  end;
end method;



/// Pretty-printer support.

/// The methods on this page extend the pprint interface to <print-stream>s.
/// Doing this allows users to write print-object methods that attempt to do
/// pretty printing, but when print is called with pretty?: #f, all the
/// pretty printing directions in the print-object method become no-ops.
///

/// pprint-logical-block -- Method for Exported Interface.
///
/// When pretty printing, we pass the print-target of the <print-stream> to
/// the recursive call to pprint-logical-block.  This causes
/// pprint-logical-block to wrap a pretty printing stream around the actual
/// target.  The body: method of the recursive call then wraps the
/// <print-stream> around the pretty printing stream, nesting the ultimate
/// target stream twice.
///
/// In the body: method of the recursive call, there is a check to see if
/// the target is the pretty-stream argument. They are == when the body
/// function passed to this <print-stream> method contains recursive calls
/// to pprint-logical-block.  The code works without the if test, but
/// besides saving a few stores into memory with the assignments, the code
/// seemed more clear with the if test; that is, it should be more clear to
/// future maintainers of this code that the method can be reentered on the
/// same stream and what happens when this method is reentered.
///
define method pprint-logical-block (stream :: <print-stream>,
                    #key column = 0, prefix, per-line-prefix,
                     body, suffix)
    => ();
  if (prefix & per-line-prefix)
    error("Can't specify both a prefix: and a per-line-prefix:");
  end;
  case
    ((stream.print-circle?) & (stream.circular-first-pass?)) =>
      #f;   // Case is broken in Mindy.
    (stream.print-pretty?) =>
      let target = stream.print-target;
      pprint-logical-block(target,
               column: column,
               prefix: prefix,
               per-line-prefix: per-line-prefix,
               body: method (pretty-stream)
                   if (pretty-stream == target)
                     body(stream);
                   else
                     let orig-target = stream.print-target;
                     stream.print-target := pretty-stream;
                     body(stream);
                     stream.print-target := orig-target;
                   end;
                 end,
               suffix: suffix);
    otherwise =>
      if (prefix | per-line-prefix)
    write(prefix | per-line-prefix, stream);
      end;
      body(stream);
      if (suffix)
    write(suffix, stream);
      end;
  end case;
end method;

/// pprint-newline -- Method for Exported Interface.
///
define method pprint-newline (kind :: one-of(#"linear", #"miser", #"fill",
                         #"mandatory"),
                  stream :: <print-stream>)
    => ();
  case
    ((~ ((stream.print-circle?) & (stream.circular-first-pass?)))
       & stream.print-pretty?) =>
      pprint-newline(kind, stream.print-target);
    (kind == #"mandatory") =>
      write('\n', stream);
  end;
end;

define method pprint-indent (relative-to :: one-of(#"block", #"current"),
                 n :: <fixed-integer>,
                 stream :: <print-stream>)
    => ();
  if ((~ ((stream.print-circle?) & (stream.circular-first-pass?)))
    & stream.print-pretty?)
    pprint-indent(relative-to, n, stream.print-target);
  end;
end;

define method pprint-tab (kind :: one-of(#"line", #"section", #"line-relative",
                     #"section-relative"),
              colnum :: <fixed-integer>,
              colinc :: <fixed-integer>,
              stream :: <print-stream>)
    => ();
  if ((~ ((stream.print-circle?) & (stream.circular-first-pass?)))
    & stream.print-pretty?)
    pprint-tab(kind, colnum, colinc, stream.print-target);
  end;
end;